Excel - Módulos com funções utilitarias 2

Excel - Módulo de Funções Utilitárias 2

converte a coluna de número para letra

Function ConverterParaLetra(icol As Long) As String
   Dim a As Long
   Dim b As Long

   a = icol
   ConverterParaLetra = ""
   Do While icol > 0
      a = Int((icol - 1) / 26)
      b = (icol - 1) Mod 26
      ConverterParaLetra = Chr(b + 65) & ConverterParaLetra
      icol = a
   Loop
End Function

atribui uma fórmula a célula corrente

Public Sub ColocaFormulaCelulaAtual(Formula As String)
ActiveCell.Formula = Formula '"=A1+B2"
End Sub

Seleciona uma célula ou conjunto de células

conjunto pode ser uma só celula (Ex: "B9" ) ou um conjunto de células("A1:Z20")

Public Sub SelecionaConjuntoCelulas(conjunto As String)
range(conjunto).Select
End Sub

retorna o valor da célula que está selecionada

Public Function RetornaValorCelulaCorrente() As Variant
RetornaValorCelulaCorrente = ActiveCell.Value
End Function

atribui o valor a célula selecionada

Public Sub DefineValorCelulaCorrente(valor As Variant)
ActiveCell.Value = valor
'Workbooks("Custo.Xls").Sheets("Folha1").Range("A1").Value = 5
End Sub

Faz com que a célula atual fique com o conteúdo centralizado

Public Sub CelulaCorrenteCentralizarTexto()
    Selection.HorizontalAlignment = xlCenter
End Sub

Public Sub SelecionarCelula(Celula As String)
    SelecionaConjuntoCelulas (Celula)
End Sub

Public Sub ColocaValorCelulaCorrente(valor As Variant)
    ActiveCell.Value = valor
End Sub

faz com que o texto na célula corrente fique em negrito

Public Sub CelulaCorrenteFazTextoBold()
Selection.Font.Bold = True
End Sub

faz com que o texto na célula corrente fique em itálico

Public Sub CelulaCorrenteFazItalico()
Selection.Font.Italic = True
End Sub

faz com que o texto na célula corrente fique sublinhado

Public Sub SublinhaCelulaCorrente()
Selection.Font.Underline = xlUnderlineStyleSingle
End Sub

Alinha a seleção atual à direita - à esqueda (left) é o default (texto)

Public Sub CelulaCorrenteTextoDireita()
Selection.HorizontalAlignment = xlRight
End Sub

Define o tipo de letra da célula corrente

Public Sub DefineFonteLetraCelulaCorrente()
Selection.Font.Name = "AGaramond"
End Sub

elimina uma linha inteira da planilha

Public Sub EliminaLinha(NomePlanilha As String, linha As String)
    Sheets(NomePlanilha).Select
    range(linha).EntireRow.Select
    Selection.EntireRow.Delete
End Sub

procura a partir da linha 1 até encontrar a primeira coluna em branco

Nota : ao encontrar a 1a linha em branco ele varre + 40 linhas depois para ver
se continua em branco e se achou conteúdo continua a procura

Public Function PegaUltimaLinhaPlanilha(Planilha As String, col As String) As Integer
    Dim a As Integer
    Dim b As Variant
    Dim c As Integer
    Dim d As Integer
    Dim e As Integer

    c = ConverterParaNúmero(col)
    a = 1 'linha
    Sheets(Planilha).Select
    b = Cells(a, c).Value 'linha,coluna c=col , a-lin

continua:

    While b <> ""
        a = a + 1
        b = Cells(a, c).Value 'linha,coluna c=col, a=lin
    Wend

    'proteção linha em branco - 40 linhas em branco
    d = 0
    e = a
    While d < 40
        e = e + 1
        b = Cells(e, c).Value 'linha,coluna c=col, a=lin
        If b <> "" Then
            a = e
            GoTo continua
        End If
        d = d + 1
    Wend

    PegaUltimaLinhaPlanilha = a - 1
End Function

converte a coluna de string para número

Public Function ConverterParaNúmero(coluna As String) As Integer
    Dim a As Integer
    Dim b As Integer
    Dim peso As Integer
    Dim res As Integer

    peso = 0
    res = 0

    For b = Len(coluna) To 1 Step -1
        a = Asc(Mid(coluna, b, 1))
        a = a - Asc("A") + 1 * (26 ^ peso) 'Coluna AA = Coluna 27
        res = res + a
        peso = peso + 1
    Next
    ConverterParaNúmero = res

End Function

copia o valor da célula corrente para o clipboard

Public Sub CopiaCelulaCorrente()
ActiveCell.Copy
End Sub

Copia uma linha inteira de uma planilha para a outra

Nota: a linha é um string que contém números apenas

Public Sub CopiarLinhaInteira(planOrigem As String, linhaOrigem As String, planDestino As String, linhaDestino As String)

    Sheets(planOrigem).Select
    a = converte
    Rows(linhaOrigem).Select
    ActiveCell.EntireRow.Copy

    Sheets(planDestino).Select
    Rows(linhaDestino).Select
    ActiveCell.EntireRow.Insert

End Sub

elimina a linha inteira onde se encontra a seleção atual

Public Sub EliminarLinhaInteiraCorrente()
Selection.EntireRow.Delete
End Sub

Copia uma coluna inteira da Planilha Origem para a Planilha destino

Nota: Assume que a primeira linha com dados da coluna seja a segunda. A primeira é o header/cabeçalho da coluna

Public Sub CopiarColuna(planOrigem As String, ColOrigem As String, planDestino As String, colDestino As String)
    Dim a As Integer 'linha origem
    Dim b As Integer 'linha destino
    Dim c As Integer 'cont lin
    Dim d As Integer 'col origem
    Dim e As Integer 'col destino
    Dim f As Variant 'dado

    a = NumLinPedPendPag 'PegaUltimaLinhaPlanilha(planOrigem, ColOrigem)
    If planDestino = "PedidosPendPgto" Then
        b = NumLinPedPendPag + 1 'PegaUltimaLinhaPlanilha(PlanDestino, ColDestino) + 1
    End If

    d = ConverterParaNúmero(ColOrigem)
    e = ConverterParaNúmero(colDestino)

    Application.ScreenUpdating = False
    c = 2 'linha 1 tem os headers

    While c <= a
        Sheets(planOrigem).Select
        f = Cells(c, d).Value 'linha,coluna

        Sheets(planDestino).Select
        Cells(b, e) = f 'linha, coluna

        c = c + 1
        b = b + 1
    Wend

    Application.ScreenUpdating = True

End Sub

Copia as células correntes para o clipboard

Public Sub CopiaRangeCelulasSelecionadas()
Selection.Copy
End Sub

Recorta as células selecionadas (transfere o conteúdo delas para o clipboard)

Public Sub CortaRangeCelulasSelecionadas()
Selection.Cut
End Sub

ordena as células selecionadas por ordem crescente

Public Sub OrdenarSelecaoAscendente()
Selection.Sort Key1:=range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

ordena as células selecionadas por ordem decrescente

Public Sub OrdenarSelecaoDescendente()
Selection.Sort Key1:=range("A1"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

procura por um texto dentro da planilha

Public Sub Buscar(valor As String)
Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
End Sub

insere conteúdo do clipboard na linha corrente

Public Sub InserirLinhaInteiraLinhaCorrente()
    Selection.EntireRow.Insert
End Sub

Public Sub ColocaValorRangeCelulasSelecionadas(valor As Variant)
    For Each Celula In Selection
        Celula.valor = valor
    Next célula
End Sub

Elimina tudo da planilha - mas não retira cor de fundo da célula

Public Sub LimparPlanilha(nome As String)
    Sheets(nome).Select
    Sheets(nome).Cells.ClearContents
    MsgBox ("Planilha " & nome & " limpa com sucesso")
End Sub

limpa tudo da planilha, até cor de fundo da célula

Public Sub LimparPlanilha1(nome As String)
Sheets(nome).Select
Cells.Clear
End Sub

esta rotina transfere tudo de um recordset (dados trazidos do SQL) para uma planilha

'Podemos definir para onde deverá ser transferido: Qual planilha, a partir de que linha e coluna deverá começar
' a transferência
Public Sub TransfereRecordSetParaPlanilha(NomePlanilha As String, colunaPlanilha As String, LinhaPlanilha As String, Dados As adodb.Recordset)
    Dim linhas As Integer
    Dim colunas As Integer
    Dim icol As Integer
    Dim ilin As Integer

    On Error GoTo saida1

    Sheets(NomePlanilha).Select

    icol = ConverterParaNúmero(colunaPlanilha)
    ilin = CInt(LinhaPlanilha)

    'transferindo os campos de cabeçalho
    For colunas = 1 To Dados.Fields.Count
        Cells(ilin, icol).Value = Dados.Fields(icol - 1).Name 'linha, coluna
        Cells(ilin, icol).Interior.ColorIndex = 37
        icol = icol + 1
    Next
    ilin = ilin + 1

    'copiando os valores
    icol = ConverterParaNúmero(colunaPlanilha)
    While Not Dados.EOF
        For colunas = 1 To Dados.Fields.Count
            Cells(ilin, icol).Value = Dados.Fields(icol - 1).Value 'linha, coluna
            icol = icol + 1
        Next
        icol = ConverterParaNúmero(colunaPlanilha)
        ilin = ilin + 1
        Dados.MoveNext
    Wend
    Exit Sub

saida1:
    MsgBox ("Erro:" + Err.Description)

End Sub

Desligando a atualização da Planilha

Public Sub InibirAtualizacaoTela()
Application.ScreenUpdating = False
End Sub

Ligando a atualização da Planilha

Public Sub HabilitarAtualizacaoTela()
Application.ScreenUpdating = True
End Sub

Retorna a pasta do disco que a planilha se encontra

Public Function RetornaPastaPlanilha() As String
RetornaPastaPlanilha = ThisWorkbook.Path
End Function

Salva e fecha a planilha

Public Sub SalvarEFecharPlanilha()
ThisWorkbook.Saved = True
ThisWorkbook.Close
End Sub

Ativar a planilha, dar o foco - Nota: Planilha é numérico..1,2,3

Public Function AtivarPlanilha(Planilha As String)
Workbooks(Planilha).Activate
End Function

Imprimir a planilha

Public Sub ImprimirPlanilha()
'Workbooks(1).PrintOut (From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate)
End Sub

Esta função procura por um string em uma coluna da planilha e sempre que encontrar ela vai eliminar a linha inteira .

Public Sub EliminarLinhaPlanilha(NomePlanilha As String, coluna As String, dado As String)
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim col As String
    Dim lin As String

    Sheets(NomePlanilha).Select
    a = PegaUltimaLinhaPlanilha(NomePlanilha, coluna)
    c = ConverterParaNúmero(coluna)
    For b = 1 To a
        If Cells(b, c).Value = dado Then 'linha, coluna
            lin = "A" + CStr(b)
            EliminaLinha NomePlanilha, lin
        b = b - 1
        End If
    Next
End Sub

seleciona a planilha para ser utilizada

Public Sub SelecionarPlanilha(NomePlanilha As String)
Sheets(NomePlanilha).Select
End Sub

retorna o nome da planilha selecionada neste momento

Public Function RetornaNomePlanilhaCorrente() As String
RetornaNomePlanilhaCorrente = ActiveSheet.Name
End Function

fechando a planilha

Public Function FechandoPastaCorrente()
ThisWorkbook.Close
End Function

exibe uma planilha

Public Sub ExibePlanilha(NomePlanilha As String)
Sheets(NomePlanilha).Visible = True
End Sub

ocultando a planilha

Public Sub EscondePlanilha(NomePlanilha As String)
Sheets(NomePlanilha).Visible = False
End Sub

abre uma planilha externa

Public Sub AbreArquivoExcelExterno(NomeArquivoXLS As String)
'Workbooks.Open Filename:="C:\Meus documentos\video safe 3.xls"
Workbooks.Open Filename:=NomeArquivoXLS
End Sub

abre uma planilha externa com senha

Public Sub AbreArquivoExcelExternoComSenha(NomeArquivoXLS As String, Senha As String)
'ActiveWorkbook.SaveAs Filename:="C:\Meus documentos\piscis.xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=NomeArquivoXLS, FileFormat:=xlNormal, Password:=Senha, WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Recalcular a planilha inteira

Public Sub RecalcularTodaPlanilha()
ActiveSheet.Calculate
End Sub

Desligar alertas

Public Sub DesligarAlertas()
Application.DisplayAlerts = False
End Sub

Ligar Alertas

Public Sub LigarAlertas()
Application.DisplayAlerts = True
End Sub

Não Exibir a planilha em tela cheia

minimiza ou reduz dependendo estado anterior

Public Sub ExibeExcelTelaNaoCheia()
Application.DisplayFullScreen = False
End Sub

Exibir a planilha em tela cheia

Public Sub ExibeExcelTelaCheia()
Application.DisplayFullScreen = True
End Sub

Desabilita animações

Public Sub DesabilitarAnimacoes()
Application.EnableAnimations = False
End Sub

Habilita animações

Public Sub HabilitarAnimacoes()
Application.EnableAnimations = True
End Sub

Desabilita Auto-Complete

Public Sub DesabilitaAutoComplete()
Application.EnableAutoComplete = False
End Sub

Habilita auto-complete

Public Sub HabilitaAutoComplete()
Application.EnableAutoComplete = True
End Sub

Desabilita sons

Public Sub DesabilitaSons()
Application.EnableSound = False
End Sub

Habilita sons

Public Sub HabilitaSons()
Application.EnableSound = True
End Sub

Associar uma tecla a um evento

para desabilitar faça Application.OnKey "^a", " " para reativar atalho : Application.OnKey "^a"

Public Sub AssociarTeclaAUmProcedimento(tecla As String, procedimento As String)
Application.OnKey tecla, procedimento
End Sub

Inibe atualiza~ção da tela

Public Sub InibirAtualizacaoTela()
Application.ScreenUpdating = False
End Sub

Habilita atualização da tela

Public Sub HabilitarAtualizacaoTela()
Application.ScreenUpdating = True
End Sub

Exibe PopUp

exibe uma mensagem de alerta para o usuário

Public Sub ExibePopup(Mensagem As String)
MsgBox (Mensagem)
End Sub

Pergunta ao usuário

Public Function PerguntaAoUsuario(Mensagem As String) As String
    Dim a As String
    a = InputBox(Mensagem)
    PerguntaAoUsuario = a
End Function

retorna a pasta do windows que a planilha está

Public Function RetornaPastaCorrente() As String
RetornaPastaCorrente = ActiveWorkbook.Name
End Function

sair do modo programação

Public Sub TerminarExcel()
Application.Quit
End Sub

Cola o conteúdo do clipboard na célula corrente de maneira personalizada

Public Sub PasteEspecial()
ActiveCell.PasteSpecial Paste:=xlValues, operation:=xlNone, skipBlanks:=False, Transpose:=False
End Sub

Retorna a fórmula contida na célula

Public Function RetornaFormulaCelulaCorrente() As Variant
RetornaFormulaCelulaCorrente = ActiveCell.Formula
End Function

devolve true se a variável for vazia

Public Function TestaVazio(dado As Variant) As Boolean
TestaVazio = IsEmpty(dado)
End Function

devolve true se o dado for numérico

Public Function TestaNumérico(dado As Variant) As Boolean
TestaVazio = IsNumeric(dado)
End Function

Solicitando o recálculo manual da planilha

Public Sub FazendoRecalculoManual()
Application.Calculation.xlManual
End Sub

Solicitando recálculo automatico da planilha

Public Sub FazendoRecalculoAutomatico()
Application.Calculation.xlAutomatic
End Sub

Dar foco a uma planilha

Public Sub DeslocarVisualização(range As String)
ActiveSheet.ScrollArea = range '"A1: D20"
End Sub